home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / clean / sun3.lha / Sun3 / system.abc < prev   
Text File  |  1992-08-07  |  8KB  |  449 lines
  1. | The system environment (for version numbers 0.80 etc)
  2. |
  3. .comp 800 111111111
  4. .code    190 16 45
  5. .start _no_start
  6. .endinfo
  7.  
  8. .export            EMPTY INT BOOL CHAR STRING REAL _ARRAY FILE
  9. .export            _Ind _ind_code
  10. .export            _Defer _defer_code
  11. .export            _Copy _copy_code _channel_code
  12. .export            _reserve
  13. .export            _hnf_reducer _nf_reducer _cont_reducer
  14. .export            _HnfReducer _NfReducer _ContReducer
  15. .export            _hnf _cycle_in_spine _type_error _driver
  16. .export            _Tuple
  17. .export            _S.1 _S.2 _S.3 _S.4 _S.5 _S.6 n_S.1 n_S.2 n_S.3 n_S.4 n_S.5 n_S.6
  18. .export            _Nil _Cons
  19. .export            e_system_AP e_system_sAP e_system_nAP
  20. .export            e_system_IF e_system_lIF e_system_sIF e_system_nIF
  21. .export            _match_error _add_arg
  22.  
  23. ||    Basic Node Descriptors
  24.  
  25. .desc EMPTY        _hnf        _hnf        0    "EMPTY"
  26. .desc INT        _hnf        _hnf        0    "INT"
  27. .desc BOOL        _hnf        _hnf        0    "BOOL"
  28. .desc CHAR        _hnf        _hnf        0    "CHAR"
  29. .desc REAL        _hnf        _hnf        0    "REAL"
  30. .desc STRING    _hnf        _hnf        0    "STRING"
  31. .desc FILE        _hnf        _hnf        0    "FILE"
  32. .desc _ARRAY    _hnf        _hnf        0    "_ARRAY"
  33.  
  34. ||    Special Node Descriptors
  35.  
  36. .desc _Tuple        _hnf            _hnf            32    "_Tuple"
  37. .desc _Select        _hnf            _hnf            2    "_Select"
  38. .desc _Nil            _hnf            _hnf            0    "Nil"
  39. .desc _Cons            _hnf            _l_cons            2    "Cons"
  40. .desc e_system_AP    e_system_nAP    e_system_lAP    2    "AP"
  41. .desc e_system_IF    e_system_nIF    e_system_lIF    3    "IF"
  42.  
  43. ||    Reducer Descriptors
  44.  
  45. .desc _HnfReducer    _hnf_reducer    _hnf_reducer    0    "HnfReducer"
  46. .desc _NfReducer    _nf_reducer        _nf_reducer        0    "NfReducer"
  47. .desc _ContReducer    _cont_reducer    _cont_reducer    0    "ContReducer"
  48.  
  49. _match_error:
  50.             print    "Run time error, rule \'"
  51.             printD
  52.             print    "\' in module \'"
  53.             printD
  54.             print    "\' does not match\n"
  55.             halt
  56.  
  57. _l_cons:    create
  58.             push_a                2
  59.             push_args            2 2 2
  60.             fill _Cons 2 _hnf    2
  61.             update_a            0 2
  62.             pop_a                2
  63.             rtn
  64.  
  65. .desc _S.1    n_S.1    _hnf    1    "_S.1"
  66. .n 1 _S.1
  67. .o 1 0
  68. n_S.1:
  69.     push_node _reserve 1
  70.     jsr_eval
  71.     get_node_arity 0
  72.     pushI 1
  73.     push_arg_b 0
  74.     jsr_eval
  75.     getWL 2
  76.     fill_a 0 2
  77.     release
  78.     pop_a 2
  79. .d 1 0
  80.     rtn
  81.  
  82. .desc _S.2    n_S.2    _hnf    1    "_S.2"
  83. .n 1 _S.2
  84. .o 1 0
  85. n_S.2:
  86.     push_node _reserve 1
  87.     jsr_eval
  88.     get_node_arity 0
  89.     pushI 2
  90.     push_arg_b 0
  91.     jsr_eval
  92.     getWL 2
  93.     fill_a 0 2
  94.     release
  95.     pop_a 2
  96. .d 1 0
  97.     rtn
  98.  
  99. .desc _S.3    n_S.3    _hnf    1    "_S.3"
  100. .n 1 _S.3
  101. .o 1 0
  102. n_S.3:
  103.     push_node _reserve 1
  104.     jsr_eval
  105.     get_node_arity 0
  106.     pushI 3
  107.     push_arg_b 0
  108.     jsr_eval
  109.     getWL 2
  110.     fill_a 0 2
  111.     release
  112.     pop_a 2
  113. .d 1 0
  114.     rtn
  115.  
  116. .desc _S.4    n_S.4    _hnf    1    "_S.4"
  117. .n 1 _S.4
  118. .o 1 0
  119. n_S.4:
  120.     push_node _reserve 1
  121.     jsr_eval
  122.     get_node_arity 0
  123.     pushI 4
  124.     push_arg_b 0
  125.     jsr_eval
  126.     getWL 2
  127.     fill_a 0 2
  128.     release
  129.     pop_a 2
  130. .d 1 0
  131.     rtn
  132.  
  133. .desc _S.5    n_S.5    _hnf    1    "_S.5"
  134. .n 1 _S.5
  135. .o 1 0
  136. n_S.5:
  137.     push_node _reserve 1
  138.     jsr_eval
  139.     get_node_arity 0
  140.     pushI 5
  141.     push_arg_b 0
  142.     jsr_eval
  143.     getWL 2
  144.     fill_a 0 2
  145.     release
  146.     pop_a 2
  147. .d 1 0
  148.     rtn
  149.  
  150. .desc _S.6    n_S.6    _hnf    1    "_S.6"
  151. .n 1 _S.6
  152. .o 1 0
  153. n_S.6:
  154.     push_node _reserve 1
  155.     jsr_eval
  156.     get_node_arity 0
  157.     pushI 6
  158.     push_arg_b 0
  159.     jsr_eval
  160.     getWL 2
  161.     fill_a 0 2
  162.     release
  163.     pop_a 2
  164. .d 1 0
  165.     rtn
  166.  
  167. e_system_lAP:
  168.             print        "Error: lazy entry of AP entered"
  169.             halt
  170. e_system_nAP:
  171.             push_node    _reserve 2
  172.             jsr_eval
  173.             jsr             e_system_sAP
  174.             getWL            1
  175.             fill_a            0 1
  176.             release
  177.             pop_a            1
  178.             rtn
  179.             
  180. e_system_sAP:
  181.             get_node_arity    0
  182.             get_desc_arity    0
  183.             subI
  184.             eqI_b            +1 0
  185.             jmp_false        _add_arg
  186.             push_ap_entry    0
  187.             pop_b            1
  188.             rtn
  189. _add_arg:
  190.             create
  191.             push_a        2
  192.             add_args    2 1 1
  193.             update_a    0 2
  194.             pop_a        2
  195.             pop_b        1
  196.             rtn
  197.  
  198. .o 2 0
  199. e_system_lIF:
  200.             repl_args 2 2
  201. .d 3 0
  202.             jmp eval_args_if
  203. .n 3 e_system_IF
  204. .o 1 0
  205. e_system_nIF:
  206.             push_node _reserve 3
  207. .d 3 0
  208.             jsr eval_args_if
  209. .o 1 0
  210.             getWL 1
  211.             fill_a 0 1
  212.             release
  213.             pop_a 1
  214. .d 1 0
  215.             rtn
  216. .o 3 0
  217. eval_args_if:
  218.             jsr_eval
  219.             pushB_a 0
  220.             pop_a 1
  221.  
  222. .o 2 1 b
  223. e_system_sIF:
  224.             jmp_false IFelse
  225.             update_a 0 1
  226.             pop_a 1
  227.             jmp_eval
  228. IFelse:
  229.             pop_a 1
  230.             jmp_eval
  231.             
  232. _hnf:        rtn
  233.  
  234. _reserve:    setwait        0
  235.             suspend
  236.             rtn
  237.  
  238. _hnf_reducer:
  239.             get_node
  240.             jmp_false    _stop
  241. ||            is_reserved    0
  242. ||            jmp_true    _done
  243.             jsr_eval
  244. _done:        pop_a        1
  245.             jmp            _hnf_reducer
  246. _stop:        stop_reducer
  247.  
  248. _cont_reducer:
  249.             get_node
  250.             jmp_false    _susp
  251.             is_reserved    0
  252.             jmp_true    _done2
  253.             jsr_eval
  254. _done2:        pop_a        1
  255.             jmp            _cont_reducer
  256. _susp:        suspend
  257.             jmp _cont_reducer
  258.  
  259.  
  260. _cycle_in_spine:
  261.                 print        "Run Time Error: cycle in spine detected\n"
  262.                 halt
  263.  
  264. _type_error:    print        "Run Time Error: type error\n"
  265.                 halt
  266.  
  267. _apply_error:    print        "Run Time Error: apply error\n"
  268.                 halt
  269.  
  270.  
  271. .desc _Defer    _defer_code    _apply_error    1    "_Defer"
  272. .desc _Copy        _copy_code    _apply_error    1    "_Copy"
  273. .desc _Ind        _ind_code    _apply_error    1    "_I"
  274.  
  275. _defer_code:
  276.             push_node        _reserve 1
  277. ||            set_red_id        1
  278. ||            force_cswitch
  279.             jsr_eval
  280.             getWL            1
  281.             fill_a            0 1
  282.             release
  283.             pop_a            1
  284.             rtn
  285.  
  286. _copy_code:    push_node        _reserve 1
  287.             jsr_eval
  288.             copy_graph        0
  289.             getWL            2
  290.             fill_a            0 2
  291.             release
  292.             pop_a            2
  293.             rtn
  294.                     
  295. _channel_code:
  296.             push_node        _reserve 0
  297.             send_request    0
  298.             setwait            0
  299.             suspend
  300.             rtn
  301.  
  302. _ind_code:    push_node        _reserve 1
  303.             jsr_eval
  304.             getWL            1
  305.             fill_a            0 1
  306.             release
  307.             pop_a            1
  308.             rtn
  309.  
  310.  
  311. _driver:    jsr            _print
  312.             print_sc    "\n"
  313.             halt
  314.  
  315. _print:        pushI            0                    | push the bracket count
  316. _continue_print:
  317.             jsr_eval
  318.             eq_desc            _ARRAY 0 0
  319.             jmp_true        _print_array
  320.             eq_desc            _Cons 2 0
  321.             jmp_true        _print_list
  322.             eq_nulldesc        _Tuple 0
  323.             jmp_true        _print_tuple
  324.             eq_desc            _Nil 0 0
  325.             jmp_true        _print_nil
  326.             get_node_arity    0
  327.             eqI_b            0 0                    | check if arity is zero
  328.             jmp_true        _print_last
  329.             print_sc        "("
  330.             print_symbol_sc    0
  331.             push_b            0                    | replace the node by
  332.             push_b            0
  333.             repl_args_b                            | its arguments
  334. _print_args:
  335.             print_sc        " "
  336.             eqI_b            1 0                    | check if last argument
  337.             jmp_true        _print_last_arg
  338.             jsr                _print
  339.             decI                                | decrease argument count
  340.             jmp                _print_args
  341. _print_last_arg:
  342.             pop_b            1                    | remove argument count
  343.             incI                                | increment bracket count
  344.             jmp                _continue_print        | optimised tail recursion!
  345. _print_last:
  346.             print_symbol_sc    0
  347.             pop_b            1                    | remove arity
  348.             pop_a            1                    | remove node
  349. _print_brackets:
  350.             eqI_b            0 0                    | stop printing brackets if
  351.             jmp_true        _exit_brackets        | bracket count is zero
  352.             print_sc        ")"
  353.             decI                                | decrement bracket count
  354.             jmp                _print_brackets
  355. _exit_brackets:
  356.             pop_b            1                    | remove bracket count
  357.             rtn
  358. _print_array:
  359.             print_sc        "["
  360.             get_arraysize    0
  361.             pushI            0
  362. _print_array_args:
  363.             push_b            0
  364.             push_b            2
  365.             eqI
  366.             jmp_true        _exit_print_array
  367.             eqI_b            +0 0
  368.             jmp_true        _not_first_arg
  369.             print_sc        ","
  370. _not_first_arg:
  371.             select            0 0
  372.             jsr                _print
  373.             incI
  374.             jmp                _print_array_args
  375. _exit_print_array:
  376.             print_sc        "]"
  377.             pop_a            1
  378.             pop_b            2
  379.             jmp                _print_brackets
  380.  
  381. _print_list:
  382.             print_sc        "["
  383. _print_rest_list:
  384.             repl_args        2 2
  385.             jsr                _print
  386.             jsr_eval
  387.             eq_desc            _Nil 0 0
  388.             jmp_true        _print_last_list
  389.             print_sc        ","
  390.             jmp                _print_rest_list            
  391. _print_last_list:
  392.             print_sc        "]"
  393.             pop_a            1
  394.             jmp                _print_brackets
  395.                     
  396. _print_nil:
  397.             print_sc        "[]"
  398.             pop_a            1
  399.             jmp                _print_brackets
  400.  
  401. _print_tuple:            
  402.             print_sc        "("
  403.             get_node_arity    0
  404.             push_b            0
  405.             push_b            0
  406.             repl_args_b
  407. _print_rest_tuple:
  408.             jsr                _print
  409.             decI
  410.             eqI_b            0 0
  411.             jmp_true        _exit_print_tuple
  412.             print_sc        ","
  413.             jmp                _print_rest_tuple
  414. _exit_print_tuple:
  415.             pop_b            1
  416.             print_sc        ")"
  417.             jmp                _print_brackets
  418.  
  419.  
  420.  
  421. _nf_reduce:
  422.             jsr_eval
  423.             get_node_arity    0
  424.             eqI_b            0 0                    | check if arity is zero
  425.             jmp_true        _last1
  426.             push_b            0                    | replace the node by
  427.             push_b            0
  428.             repl_args_b                            | its arguments
  429. _reduce_args:
  430.             eqI_b            0 0                    | check nr of args to do
  431.             jmp_true        _last
  432.             jsr                _nf_reduce
  433.             decI
  434.             jmp                _reduce_args
  435. _last1:        pop_a            1
  436. _last:        pop_b            1
  437.             rtn
  438.  
  439.  
  440. _nf_reducer:
  441.             get_node
  442.             jmp_false    _nf_stop
  443.             jsr            _nf_reduce
  444.             jmp            _nf_reducer
  445. _nf_stop:    stop_reducer
  446.  
  447.  
  448.  
  449.